home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / envanal.lisp < prev    next >
Encoding:
Text File  |  1991-12-11  |  14.1 KB  |  392 lines

  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: envanal.lisp,v 1.20 91/12/11 16:52:24 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    The environment analysis phase for the compiler.  This phase annotates
  15. ;;; IR1 with a hierarchy environment structures, determining the environment
  16. ;;; that each Lambda allocates its variables and finding what values are closed
  17. ;;; over by each environment.
  18. ;;;
  19. ;;; Written by Rob MacLachlan
  20. ;;;
  21. (in-package 'c)
  22.  
  23.  
  24. ;;; Environment-Analyze  --  Interface
  25. ;;;
  26. ;;;    Do environment analysis on the code in Component.  This involves various
  27. ;;; things:
  28. ;;;  1] Make an Environment structure for each non-let lambda, assigning the
  29. ;;;     lambda-environment for all lambdas.
  30. ;;;  2] Find all values that need to be closed over by each environment.
  31. ;;;  3] Scan the blocks in the component closing over non-local-exit
  32. ;;;     continuations.
  33. ;;;  4] Delete all non-top-level functions with no references.  This should
  34. ;;;     only get functions with non-NULL kinds, since normal functions are
  35. ;;;     deleted when their references go to zero.
  36. ;;;
  37. (defun environment-analyze (component)
  38.   (declare (type component component))
  39.   (assert (not (component-new-functions component)))
  40.   (dolist (fun (component-lambdas component))
  41.     (reinit-lambda-environment fun))
  42.   (dolist (fun (component-lambdas component))
  43.     (compute-closure fun)
  44.     (dolist (let (lambda-lets fun))
  45.       (compute-closure let)))
  46.   
  47.   (find-non-local-exits component)
  48.   (find-cleanup-points component)
  49.   (tail-annotate component)
  50.  
  51.   (dolist (fun (component-lambdas component))
  52.     (when (null (leaf-refs fun))
  53.       (let ((kind (functional-kind fun)))
  54.     (unless (eq kind :top-level)
  55.       (assert (member kind '(:optional :cleanup :escape)))
  56.       (setf (functional-kind fun) nil)
  57.       (delete-lambda fun)))))
  58.  
  59.   (undefined-value))
  60.  
  61.  
  62. ;;; PRE-ENVIRONMENT-ANALYZE-TOP-LEVEL  --  Interface
  63. ;;;
  64. ;;;    Called on component with top-level lambdas before the compilation of the
  65. ;;; associated non-top-level code to detect closed over top-level variables.
  66. ;;; We just do COMPUTE-CLOSURE on all the lambdas.  This will pre-allocate
  67. ;;; environments for all the functions with closed-over top-level variables.
  68. ;;; The post-pass will use the existing structure, rather than allocating a new
  69. ;;; one.
  70. ;;;
  71. (defun pre-environment-analyze-top-level (component)
  72.   (declare (type component component))
  73.   (dolist (lambda (component-lambdas component))
  74.     (compute-closure lambda)
  75.     (dolist (let (lambda-lets lambda))
  76.       (compute-closure let)))
  77.   (undefined-value))
  78.  
  79.  
  80. ;;; GET-LAMBDA-ENVIRONMENT  --  Internal
  81. ;;;
  82. ;;;    If Fun has an environment, return it, otherwise assign one.
  83. ;;;
  84. (defun get-lambda-environment (fun)
  85.   (declare (type clambda fun))
  86.   (let* ((fun (lambda-home fun))
  87.      (env (lambda-environment fun)))
  88.     (or env
  89.     (let ((res (make-environment :function fun)))
  90.       (setf (lambda-environment fun) res)
  91.       (dolist (lambda (lambda-lets fun))
  92.         (setf (lambda-environment lambda) res))
  93.       res))))
  94.  
  95.  
  96. ;;; REINIT-LAMBDA-ENVIRONMENT  --  Internal
  97. ;;;
  98. ;;;    If Fun has no environment, assign one, otherwise clean up variables that
  99. ;;; have no sets or refs.  If a var has no references, we remove it from the
  100. ;;; closure.  If it has no sets, we clear the INDIRECT flag.  This is
  101. ;;; necessary because pre-analysis is done before optimization.
  102. ;;;
  103. (defun reinit-lambda-environment (fun)
  104.   (let ((old (lambda-environment (lambda-home fun))))
  105.     (cond (old
  106.        (setf (environment-closure old)
  107.          (delete-if #'(lambda (x)
  108.                 (and (lambda-var-p x)
  109.                      (null (leaf-refs x))))
  110.                 (environment-closure old)))
  111.        (flet ((clear (fun)
  112.             (dolist (var (lambda-vars fun))
  113.               (unless (lambda-var-sets var)
  114.             (setf (lambda-var-indirect var) nil)))))
  115.          (clear fun)
  116.          (dolist (let (lambda-lets fun))
  117.            (clear let))))
  118.       (t
  119.        (get-lambda-environment fun))))
  120.   (undefined-value))
  121.  
  122.  
  123. ;;; GET-NODE-ENVIRONMENT  --  Internal
  124. ;;;
  125. ;;;    Get node's environment, assigning one if necessary.
  126. ;;; 
  127. (defun get-node-environment (node)
  128.   (declare (type node node))
  129.   (get-lambda-environment (node-home-lambda node)))
  130.  
  131.  
  132. ;;; Compute-Closure  --  Internal
  133. ;;;
  134. ;;;    Find any variables in Fun with references outside of the home
  135. ;;; environment and close over them.  If a closed over variable is set, then we
  136. ;;; set the Indirect flag so that we will know the closed over value is really
  137. ;;; a pointer to the value cell.  We also warn about unreferenced variables
  138. ;;; here, just because it's a convenient place to do it.
  139. ;;;
  140. (defun compute-closure (fun)
  141.   (declare (type clambda fun))
  142.   (let ((env (get-lambda-environment fun)))
  143.     (note-unreferenced-vars fun)
  144.     (dolist (var (lambda-vars fun))
  145.       (dolist (ref (leaf-refs var))
  146.     (let ((ref-env (get-node-environment ref)))
  147.       (unless (eq ref-env env)
  148.         (when (lambda-var-sets var)
  149.           (setf (lambda-var-indirect var) t))
  150.         (close-over var ref-env env))))
  151.       (dolist (set (basic-var-sets var))
  152.     (let ((set-env (get-node-environment set)))
  153.       (unless (eq set-env env)
  154.         (setf (lambda-var-indirect var) t)
  155.         (close-over var set-env env))))))
  156.   
  157.   (undefined-value))
  158.  
  159.  
  160. ;;; Close-Over  --  Internal
  161. ;;;
  162. ;;;    Make sure that Thing is closed over in Ref-Env and in all environments
  163. ;;; for the functions that reference Ref-Env's function (not just calls.)
  164. ;;; Home-Env is Thing's home environment.  When we reach the home environment,
  165. ;;; we stop propagating the closure.
  166. ;;;
  167. (defun close-over (thing ref-env home-env)
  168.   (declare (type environment ref-env home-env))
  169.   (cond ((eq ref-env home-env))
  170.     ((member thing (environment-closure ref-env)))
  171.     (t
  172.      (push thing (environment-closure ref-env))
  173.      (dolist (call (leaf-refs (environment-function ref-env)))
  174.        (close-over thing (get-node-environment call) home-env))))
  175.   (undefined-value))
  176.  
  177.  
  178. ;;;; Non-local exit:
  179.  
  180.  
  181. ;;; Insert-NLX-Entry-Stub  --  Internal
  182. ;;;
  183. ;;;    Insert the entry stub before the original exit target, and add a new
  184. ;;; entry to the Environment-Nlx-Info.  The %NLX-Entry call in the stub is
  185. ;;; passed the NLX-Info as an argument so that the back end knows what entry is
  186. ;;; being done.
  187. ;;;
  188. ;;; The link from the Exit block to the entry stub is changed to be a link to
  189. ;;; the component head.  Similarly, the Exit block is linked to the component
  190. ;;; tail.  This leaves the entry stub reachable, but makes the flow graph less
  191. ;;; confusing to flow analysis.
  192. ;;;
  193. ;;; If a catch or an unwind-protect, then we set the Lexenv for the last node
  194. ;;; in the cleanup code to be the enclosing environment, to represent the fact
  195. ;;; that the binding was undone as a side-effect of the exit.  This will cause
  196. ;;; a lexical exit to be broken up if we are actually exiting the scope (i.e.
  197. ;;; a BLOCK), and will also do any other cleanups that may have to be done on
  198. ;;; the way.
  199. ;;;
  200. (defun insert-nlx-entry-stub (exit env)
  201.   (declare (type environment env) (type exit exit))
  202.   (let* ((exit-block (node-block exit))
  203.      (next-block (first (block-succ exit-block)))
  204.      (cleanup (entry-cleanup (exit-entry exit)))
  205.      (info (make-nlx-info :cleanup cleanup
  206.                   :continuation (node-cont exit)))
  207.      (entry (exit-entry exit))
  208.      (new-block (insert-cleanup-code exit-block next-block
  209.                      entry
  210.                      `(%nlx-entry ',info)
  211.                      (entry-cleanup entry)))
  212.      (component (block-component new-block)))
  213.     (unlink-blocks exit-block new-block)
  214.     (link-blocks exit-block (component-tail component))
  215.     (link-blocks (component-head component) new-block)
  216.     
  217.     (setf (nlx-info-target info) new-block)
  218.     (push info (environment-nlx-info env))
  219.     (push info (cleanup-nlx-info cleanup))
  220.     (when (member (cleanup-kind cleanup) '(:catch :unwind-protect))
  221.       (setf (node-lexenv (block-last new-block))
  222.         (node-lexenv entry))))
  223.   
  224.   (undefined-value))
  225.  
  226.  
  227. ;;; Note-Non-Local-Exit  --  Internal
  228. ;;;
  229. ;;;    Do stuff necessary to represent a non-local exit from the node Exit into
  230. ;;; Env.  This is called for each non-local exit node, of which there may be
  231. ;;; several per exit continuation.  This is what we do:
  232. ;;; -- If there isn't any NLX-Info entry in the environment, make an entry
  233. ;;;    stub, otherwise just move the exit block link to the component tail.
  234. ;;; -- Close over the NLX-Info in the exit environment.
  235. ;;; -- If the exit is from an :Escape function, then substitute a constant
  236. ;;;    reference to NLX-Info structure for the escape function reference.  This
  237. ;;;    will cause the escape function to be deleted (although not removed from
  238. ;;;    the DFO.)  The escape function is no longer needed, and we don't want to
  239. ;;;    emit code for it.  We then also change the %NLX-ENTRY call to use
  240. ;;;    the NLX continuation so that there will be a use to represent the NLX
  241. ;;;    use.
  242. ;;;
  243. (defun note-non-local-exit (env exit)
  244.   (declare (type environment env) (type exit exit))
  245.   (let ((entry (exit-entry exit))
  246.     (cont (node-cont exit))
  247.     (exit-fun (node-home-lambda exit)))
  248.  
  249.     (if (find-nlx-info entry cont)
  250.     (let ((block (node-block exit)))
  251.       (assert (= (length (block-succ block)) 1))
  252.       (unlink-blocks block (first (block-succ block)))
  253.       (link-blocks block (component-tail (block-component block))))
  254.     (insert-nlx-entry-stub exit env))
  255.  
  256.     (let ((info (find-nlx-info entry cont)))
  257.       (assert info)
  258.       (close-over info (node-environment exit) env)
  259.       (when (eq (functional-kind exit-fun) :escape)
  260.     (mapc #'(lambda (x)
  261.           (setf (node-derived-type x) *wild-type*))
  262.           (leaf-refs exit-fun))
  263.     (substitute-leaf (find-constant info) exit-fun)
  264.     (let ((node (block-last (nlx-info-target info))))
  265.       (delete-continuation-use node)
  266.       (add-continuation-use node (nlx-info-continuation info))))))
  267.  
  268.   (undefined-value))
  269.  
  270.  
  271. ;;; Find-Non-Local-Exits  --  Internal
  272. ;;;
  273. ;;;    Iterate over the Exits in Component, calling Note-Non-Local-Exit when we
  274. ;;; find a block that ends in a non-local Exit node.  We also ensure that all
  275. ;;; Exit nodes are either non-local or degenerate by calling IR1-Optimize-Exit
  276. ;;; on local exits.  This makes life simpler for later phases.
  277. ;;;
  278. (defun find-non-local-exits (component)
  279.   (declare (type component component))
  280.   (dolist (lambda (component-lambdas component))
  281.     (dolist (entry (lambda-entries lambda))
  282.       (dolist (exit (entry-exits entry))
  283.     (let ((target-env (node-environment entry)))
  284.       (if (eq (node-environment exit) target-env)
  285.           (unless *converting-for-interpreter*
  286.         (maybe-delete-exit exit))
  287.           (note-non-local-exit target-env exit))))))
  288.  
  289.   (undefined-value))
  290.  
  291.  
  292. ;;;; Cleanup emission:
  293.  
  294. ;;; Emit-Cleanups  --  Internal
  295. ;;;
  296. ;;;    Zoom up the cleanup nesting until we hit Cleanup1, accumulating cleanup
  297. ;;; code as we go.  When we are done, convert the cleanup code in an implicit
  298. ;;; MV-Prog1.  We have to force local call analysis of new references to
  299. ;;; Unwind-Protect cleanup functions.  If we don't actually have to do
  300. ;;; anything, then we don't insert any cleanup code.
  301. ;;;
  302. ;;; If we do insert cleanup code, we check that Block1 doesn't end in a "tail"
  303. ;;; local call.
  304. ;;;
  305. ;;;    We don't need to adjust the ending cleanup of the cleanup block, since
  306. ;;; the cleanup blocks are inserted at the start of the DFO, and are thus never
  307. ;;; scanned.
  308. ;;;
  309. (defun emit-cleanups (block1 block2)
  310.   (declare (type cblock block1 block2))
  311.   (collect ((code)
  312.         (reanalyze-funs))
  313.     (let ((cleanup2 (block-start-cleanup block2)))
  314.       (do ((cleanup (block-end-cleanup block1)
  315.             (node-enclosing-cleanup (cleanup-mess-up cleanup))))
  316.       ((eq cleanup cleanup2))
  317.     (let* ((node (cleanup-mess-up cleanup))
  318.            (args (when (basic-combination-p node)
  319.                (basic-combination-args node))))
  320.       (ecase (cleanup-kind cleanup)
  321.         (:special-bind
  322.          (code `(%special-unbind ',(continuation-value (first args)))))
  323.         (:catch
  324.          (code `(%catch-breakup)))
  325.         (:unwind-protect
  326.          (code `(%unwind-protect-breakup))
  327.          (let ((fun (ref-leaf (continuation-use (second args)))))
  328.            (reanalyze-funs fun)
  329.            (code `(%funcall ,fun))))
  330.         ((:block :tagbody)
  331.          (dolist (nlx (cleanup-nlx-info cleanup))
  332.            (code `(%lexical-exit-breakup ',nlx)))))))
  333.  
  334.       (when (code)
  335.     (assert (not (node-tail-p (block-last block1))))
  336.     (insert-cleanup-code block1 block2
  337.                  (block-last block1)
  338.                  `(progn ,@(code)))
  339.     (dolist (fun (reanalyze-funs))
  340.       (local-call-analyze-1 fun)))))
  341.  
  342.   (undefined-value))
  343.  
  344.  
  345. ;;; Find-Cleanup-Points  --  Internal
  346. ;;;
  347. ;;;    Loop over the blocks in component, calling Emit-Cleanups when we see a
  348. ;;; successor in the same environment with a different cleanup.  We ignore the
  349. ;;; cleanup transition if it is to a cleanup enclosed by the current cleanup,
  350. ;;; since in that case we are just messing up the environment, hence this is
  351. ;;; not the place to clean it.
  352. ;;;
  353. (defun find-cleanup-points (component)
  354.   (declare (type component component))
  355.   (do-blocks (block1 component)
  356.     (let ((env1 (block-environment block1))
  357.       (cleanup1 (block-end-cleanup block1)))
  358.       (dolist (block2 (block-succ block1))
  359.     (when (block-start block2)
  360.       (let ((env2 (block-environment block2))
  361.         (cleanup2 (block-start-cleanup block2)))
  362.         (unless (or (not (eq env2 env1))
  363.             (eq cleanup1 cleanup2)
  364.             (and cleanup2
  365.                  (eq (node-enclosing-cleanup
  366.                   (cleanup-mess-up cleanup2))
  367.                  cleanup1)))
  368.           (emit-cleanups block1 block2)))))))
  369.   (undefined-value))
  370.  
  371.  
  372. ;;; Tail-Annotate  --  Internal
  373. ;;;
  374. ;;;    Mark all tail-recursive uses of function result continuations with the
  375. ;;; corresponding tail-set.  Nodes whose type is NIL (i.e. don't return) such
  376. ;;; as calls to ERROR are never annotated as tail in order to preserve
  377. ;;; debugging information.
  378. ;;;
  379. (defun tail-annotate (component)
  380.   (declare (type component component))
  381.   (dolist (fun (component-lambdas component))
  382.     (let ((ret (lambda-return fun)))
  383.       (when ret
  384.     (let ((result (return-result ret)))
  385.       (do-uses (use result)
  386.         (when (and (immediately-used-p result use)
  387.              (or (not (eq (node-derived-type use) *empty-type*))
  388.              (not (basic-combination-p use))
  389.              (eq (basic-combination-kind use) :local)))
  390.         (setf (node-tail-p use) t)))))))
  391.   (undefined-value))
  392.